Personal Computer World 2006 May/PCWMAY06.iso/Software/Trial/ConceptDraw NetDiagrammer/data1.cab/Samples__Basic/Solutions/OrgChart/OrgDBConverter.cdb

Text File | 2006-02-08 | 18KB | 365 lines

'Группа массивов, содержащих данные о сотрудниках. Каждому сотруднику соответствуют данные
'с одинаковым индексом. Нулевой индекс соответствует фиктивному сотруднику самого верхнего уровня.
'Вводится для упрощения алгоритма. Реальные руководители самого верхнего уровня считаются подчиненными
'этого условного сотрудника.

'ID данного сотрудника в текстовой базе данных
Dim asID() As String
'ID непосредственного начальника данного сотрудника в текстовой базе данных
Dim asChiefID() As String
'ФИО сотрудника
Dim asName() As String
'Должность сотрудника
Dim asPost() As String
'Адрес электронной почты сотрудника
Dim asEMail() As String
'Уровень вложенности объекта, представляющего сотрудника, в общей иерархии
Dim aiLevel() As Integer
'Ширина ветви, порождаемой данным сотрудником
Dim adBranchWidth() As Double
'Высота ветви, порождаемой данным сотрудником
Dim adBranchHeight() As Double
'Флаг, указывающий, что данный сотрудник порождает ветвь, которую следует изобразить на отдельной странице
Dim abNewPage() As Boolean
'Количество подчиненных у данного сотрудника
Dim asSubordCount() As Integer
'Двумерный массив. Для каждого сотрудника содержит индексы всех его подчиненных. Позволяет
'обрабатывать схему как древовидную структуру.
Dim asSubordinates() As Integer
'Верхняя граница этих массивов
Dim iUBound As Integer
'Верхняя граница второй размерности массива asSubordinates
Dim iUBound2 As Integer

'Название компании
Dim strOrgName As String

'Текстовый буфер, в который зачитываются символы из XML-файла
Dim strBuffer As String


Declare Sub ConvertTXTToXML()
Declare Function BuildOrgTreeFromTXT(ByRef strTextFileName As String) As Boolean
Declare Function SaveDataInXML(ByRef strXMLFileName As String) As Boolean
Declare Function ReplaceSymbols(ByVal strText As String) As String
Declare Function SavePersonDataInXML(ByVal intFileNumber As Integer, ByVal intIndexInArray As Integer, ByVal intTabCount As Integer) As Boolean
Declare Sub ConvertXMLToTXT()
Declare Function BuildOrgTreeFromXML(ByRef strXMLFileName As String) As Boolean
Declare Sub RedimArrays(ByVal intUBound As Integer, ByVal intUBound2 As Integer)
Declare Function ReReplaceSymbols(ByRef strText As String) As String
Declare Sub ReplaceChr10And13(ByRef strText As String)
Declare Function GetXMLTextValue(ByRef strTagValue As String, ByVal intFileNumber As Integer) As Integer
Declare Function GetXMLTag(ByRef strTag As String, ByVal intFileNumber As Integer) As Integer
Declare Function SaveDataInTXT(ByRef strTXTFileName As String) As Boolean

#INCLUDE "consts.cdb"
#INCLUDE "loadTXTFunctions.cdb"
#INCLUDE "loadXMLFunctions.cdb"


'========================================================================================================================
'========================================================================================================================

'Создание пользовательского меню. Автоматически вызывается при открытии документа из
'макроса уровня документа.
Sub CreateUserMenu()
    Dim custMenu As Menu
    Dim newMenuItem As MenuItem

    Set custMenu = thisDoc.CustomMenu
    custMenu.Caption = "E&xport DataBase"
    custMenu.RemoveAll()

    Set newMenuItem = custMenu.AddMenuItem(0)
    newMenuItem.Caption = "Export &Text DataBase To XML OrgChart Format"
    newMenuItem.SetCmdProcessing("ConvertTXTToXML")

    Set newMenuItem = custMenu.AddMenuItem(0)
    newMenuItem.Caption = "Export &XML OrgChart Format To Text DataBase"
    newMenuItem.SetCmdProcessing("ConvertXMLToTXT")
End Sub

'========================================================================================================================
'========================================================================================================================

'Основная управляющая процедура, преобразующая данные из текстового формата в XML-формат
Sub ConvertTXTToXML()
On Error GoTo ErrHandler
    Dim strTextFileName As String
    Dim strXMLFileName As String
    Dim bContinue As Boolean
    Dim bReturnedVal As Boolean

    'Получить имя текстового файла, описывающего структуру организации.
    strTextFileName = GetOpenFileName("txt","Text Files")
    If strTextFileName <> "" Then
        'Если имя получено, предложить имя-по-умолчанию для нового XML-файла...
        If Right(strTextFileName, 4) = ".txt" Then
            strXMLFileName = Left(strTextFileName, Len(strTextFileName) - 4)
        Else
            strXMLFileName = strTextFileName
        End If
        '...и получить имя XML-файла для записи.
        strXMLFileName = GetSaveFileName(constrXMLFileExt, "CDBasic OrgChart XML Files",,strXMLFileName)
        Do
            bContinue = True
            'Если файл уже существует...
            If Dir(strXMLFileName) <> "" Then
                '...проверить, не является ли файл Read-Only.
                If (GetAttr(strXMLFileName ) And cdbReadOnly) > 0 Then
                    'Если файл Read-Only, запросить подтверждение на перезапись содержимого файла.
                    bContinue = (MsgBox(sconstReadOnlyWarning, cdbInformation + cdbOKCancel) = cdbOK)
                    If Not bContinue Then
                        strXMLFileName = GetSaveFileName(constrXMLFileExt, "CDBasic OrgChart XML Files",,strXMLFileName)
                    End If
                End If
            End If
        Loop Until bContinue
        If strXMLFileName <> "" Then
        'Если получено имя файла для экспорта в XML, то зачитать данные из текстового файла.
            If BuildOrgTreeFromTXT(strTextFileName) Then
                'Если данные зачитаны успешно, записать эти данные в XML-формате.
                If SaveDataInXML(strXMLFileName) Then
                    'Если данные еще и записались успешно, сообщить о выполнении задачи.
                    MsgBox("Textovaja baza dannih bila uspeshno konvertirovana v XML-format.")
                End If
            End If
        End If
    End If
    Exit Sub

ErrHandler:
    MsgBox ("In performing the macros, an error has occured.", cdbExclamation)

End Sub

'========================================================================================================================
'========================================================================================================================

'Основная управляющая процедура, преобразующая данные из XML-формата в формат текстовой базы данных.
Sub ConvertXMLToTXT()
On Error GoTo ErrHandler
    Dim strTXTFileName As String
    Dim strXMLFileName As String
    Dim bContinue As Boolean
    Dim bReturnedVal As Boolean

    'Получить имя XML- файла, описывающего структуру организации.
    strXMLFileName = GetOpenFileName(constrXMLFileExt,"CDBasic OrgChart XML Files")
    If strXMLFileName <> "" Then
        'Если имя получено, предложить имя-по-умолчанию для нового текстового файла...
        If Right(strXMLFileName, 4) = "." & constrXMLFileExt Then
            strTXTFileName = Left(strXMLFileName, Len(strXMLFileName) - 4)
        Else
            strTXTFileName = strXMLFileName
        End If
        '...и получить имя текстового файла для записи.
        strTXTFileName = GetSaveFileName("txt", "Text Files",,strTXTFileName)
        Do
            bContinue = True
            'Если файл уже существует...
            If Dir(strTXTFileName) <> "" Then
                '...проверить, не является ли файл Read-Only.
                If (GetAttr(strTXTFileName ) And cdbReadOnly) > 0 Then
                    'Если файл Read-Only, запросить подтверждение на перезапись содержимого файла.
                    bContinue = (MsgBox(sconstReadOnlyWarning, cdbInformation + cdbOKCancel) = cdbOK)
                    If Not bContinue Then
                        strTXTFileName = GetSaveFileName("txt", "Text Files",,strTXTFileName)
                    End If
                End If
            End If
        Loop Until bContinue
        If strTXTFileName <> "" Then
        'Если получено имя файла для экспорта в формат текстовой базы, то зачитать данные из XML-файла.
            If BuildOrgTreeFromXML(strXMLFileName) Then
                'Если данные зачитаны успешно, записать эти данные в текстовом формате.
                If SaveDataInTXT(strTXTFileName) Then
                    'Если данные еще и записались успешно, сообщить о выполнении задачи.
                    MsgBox("XML baza dannih bila uspeshno konvertirovana v textovij format.")
                End If
            End If
        End If
    End If
    Exit Sub

ErrHandler:
    MsgBox ("In performing the macros, an error has occured.", cdbExclamation)
End Sub

'========================================================================================================================
'========================================================================================================================

'Сохраняет данные о структуре организации в XML-формате
Function SaveDataInXML(ByRef strXMLFileName As String) As Boolean
On Error GoTo ErrHandleSaveDataXML
Dim intFileNumber As Integer
Dim fNoError As Boolean
Dim i As Integer

fNoError = True
'Открыть файл для записи
intFileNumber = FreeFile()
Open strXMLFileName For Output As #intFileNumber

'Записать заголовок XML
Print #intFileNumber, "<?xml version='1.0' ?>"  & Chr(13) & Chr(10) & Chr(13) & Chr(10)
Print #intFileNumber,
Print #intFileNumber, "<" & constrOrgChartTag & "  Version='100'>"

i = 0
'Для всех подчиненных условного сотрудника с нулевым индексом (реально это руководители верхнего уровня)
'записать в XML-файл их данные.
Do While i<=asSubordCount(0)-1 And fNoError
    'Вызов рекурсивной процедуры SavePersonDataInXML. Записывает в файл данные об одном сотруднике
    'и всех его подчиненных, если они существуют.
    fNoError = SavePersonDataInXML(intFileNumber, asSubordinates(0, i), 1)
    i=i+1
Loop

'Завершение записи XML
Print #intFileNumber, "</" & constrOrgChartTag & ">"

Close #intFileNumber
SaveDataInXML = fNoError
Exit Function
ErrHandleSaveDataXML:
    MsgBox ("Oshibka pri zapisi v fail.", cdbExclamation)
    SaveDataInXML = False
    Exit Function
End Function

'========================================================================================================================
'========================================================================================================================

'Сохраняет данные о структуре организации в формате текстовой базы данных
Function SaveDataInTXT(ByRef strTXTFileName As String) As Boolean
On Error GoTo ErrHandleSaveDataTXT
Dim intFileNumber As Integer
Dim i As Integer
Dim j As Integer
Dim strPrnString As String

'Открыть файл для записи
intFileNumber = FreeFile()
Open strTXTFileName For Output As #intFileNumber

'Для каждого сотрудника записать в текстовый файл запись с его данными.
'Условный сотрудник с нулевым индексом не учитывается.
For i=1 To iUBound
    strPrnString = ""
    'Формируем строку с данными сотрудника.
    'По количеству использующихся в формате полей склеиваем данные в строку.
    For j=1 To conintFieldsCount
        Select Case j
        Case conintIDPos
            strPrnString = strPrnString & asID(i) & constrCharSeparator
        Case conintNamePos
            strPrnString = strPrnString & asName(i) & constrCharSeparator
        Case conintChiefIDPos
            strPrnString = strPrnString & asChiefID(i) & constrCharSeparator
        Case conintPostPos
            strPrnString = strPrnString & asPost(i) & constrCharSeparator
        Case conintEMailPos
            strPrnString = strPrnString & asEMail(i) & constrCharSeparator
        End Select
    Next
    'От строки отбрасываем последний символ разделитель полей.
    strPrnString = Left$(strPrnString, Len(strPrnString) - 1)
    Print #intFileNumber, strPrnString
Next

Close #intFileNumber
SaveDataInTXT = True
Exit Function
ErrHandleSaveDataTXT:
    MsgBox ("Oshibka pri zapisi v fail.", cdbExclamation)
    SaveDataInTXT = False
    Exit Function
End Function

'========================================================================================================================
'========================================================================================================================

'Рекурсивная процедура. Записывает в файл данные об одном сотруднике
'и всех его подчиненных, если они существуют.
Function SavePersonDataInXML(ByVal intFileNumber As Integer, ByVal intIndexInArray As Integer, ByVal intTabCount As Integer) As Boolean
On Error GoTo ErrHandleSavePerson
    Dim i As Integer
    Dim fNoError As Boolean
    fNoError = True
    Print #intFileNumber, String$(intTabCount, Chr(9)) & "<" & constrPersonTag & ">"

    'Если значение элемента массива не является нулевой строкой, записываем в файл
    'соответствующий тэг. При этом символы, которые в XML являются служебными, заменяются описаниями.
    If asName(intIndexInArray)<>"" Then
        Print #intFileNumber, String$(intTabCount+1, Chr(9)) & "<" & constrNameTag & ">" & ReplaceSymbols(asName(intIndexInArray)) & "</" & constrNameTag & ">"
    End If

    If asPost(intIndexInArray)<>"" Then
        Print #intFileNumber, String$(intTabCount+1, Chr(9)) & "<" & constrPostTag & ">" & ReplaceSymbols(asPost(intIndexInArray)) & "</" & constrPostTag & ">"
    End If

    If asEMail(intIndexInArray)<>"" Then
        Print #intFileNumber, String$(intTabCount+1, Chr(9)) & "<" & constrEMailTag & ">" & ReplaceSymbols(asEMail(intIndexInArray)) & "</" & constrEMailTag & ">"
    End If

    'Если у сотрудника есть подчиненные, вызываем эту процедуру снова для каждого из них.
    If asSubordCount(intIndexInArray) > 0 Then
        Print #intFileNumber, String$(intTabCount+1, Chr(9)) & "<" & constrSubordinatesTag & ">"
        i=0
        Do While i<=asSubordCount(intIndexInArray)-1 And fNoError
            fNoError = SavePersonDataInXML(intFileNumber, asSubordinates(intIndexInArray, i), intTabCount + 2)
            i=i+1
        Loop
        Print #intFileNumber, String$(intTabCount+1, Chr(9)) & "</" & constrSubordinatesTag & ">"
    End If

    Print #intFileNumber, String$(intTabCount, Chr(9)) & "</" & constrPersonTag & ">"
    SavePersonDataInXML=fNoError
    Exit Function
ErrHandleSavePerson:
    MsgBox ("Oshibka pri zapisi v fail.", cdbExclamation)
    SavePersonDataInXML = False
    Exit Function
End Function

'========================================================================================================================
'========================================================================================================================

'Функция заменяет в текстовой строке символы, являющиеся служебными в XML, их описаниями.
Function ReplaceSymbols(ByVal strText As String) As String
    Dim iFindPos As Integer

    iFindPos = InStr(strText, "&")
    Do While iFindPos > 0
        strText = Left(strText, iFindPos - 1) & "&" & Right(strText, Len(strText) - iFindPos)
        iFindPos = InStr(iFindPos + 1, strText, "&")
    Loop

    iFindPos = InStr(strText, """")
    Do While iFindPos > 0
        strText = Left(strText, iFindPos - 1) & """ & Right(strText, Len(strText) - iFindPos)
        iFindPos = InStr(iFindPos + 1, strText, """")
    Loop

    iFindPos = InStr(strText, "'")
    Do While iFindPos > 0
        strText = Left(strText, iFindPos - 1) & "'" & Right(strText, Len(strText) - iFindPos)
        iFindPos = InStr(iFindPos + 1, strText, "'")
    Loop

    iFindPos = InStr(strText, "<")
    Do While iFindPos > 0
        strText = Left(strText, iFindPos - 1) & "<" & Right(strText, Len(strText) - iFindPos)
        iFindPos = InStr(iFindPos + 1, strText, "<")
    Loop

    iFindPos = InStr(strText, ">")
    Do While iFindPos > 0
        strText = Left(strText, iFindPos - 1) & ">" & Right(strText, Len(strText) - iFindPos)
        iFindPos = InStr(iFindPos + 1, strText, ">")
    Loop

    ReplaceSymbols = strText

End Function